home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / dyncount.lisp < prev    next >
Encoding:
Text File  |  1992-02-04  |  2.8 KB  |  88 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: dyncount.lisp,v 1.4 92/02/03 18:54:13 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains support for collecting dynamic vop statistics.
  15. ;;; 
  16. (in-package "C")
  17.  
  18. (export '(*collect-dynamic-statistics*))
  19.  
  20. (export '(count-me))
  21.  
  22.  
  23. (defvar *collect-dynamic-statistics* nil
  24.   "When T, emit extra code to collect dynamic statistics about vop usages.")
  25.  
  26. (defvar *dynamic-counts-tn* nil
  27.   "Holds the TN for the counts vector.")
  28.  
  29.  
  30. (defstruct (dyncount-info
  31.         (:print-function %print-dyncount-info)
  32.         (:make-load-form-fun :just-dump-it-normally))
  33.   for
  34.   (counts (required-argument) :type (simple-array (unsigned-byte 32) (*)))
  35.   (vops (required-argument) :type simple-vector))
  36.  
  37.  
  38. (defprinter dyncount-info
  39.   for
  40.   counts
  41.   vops)
  42.  
  43. (defun setup-dynamic-count-info (component)
  44.   (let* ((info (ir2-component-dyncount-info (component-info component)))
  45.      (vops (dyncount-info-vops info)))
  46.     (when (producing-fasl-file)
  47.       (fasl-validate-structure info *compile-object*))
  48.     (do-ir2-blocks (block component)
  49.       (let* ((start-vop (ir2-block-start-vop block))
  50.          (1block (ir2-block-block block))
  51.          (block-number (block-number 1block)))
  52.     (when (and start-vop block-number)
  53.       (let* ((index (1- block-number))
  54.          (counts (svref vops index))
  55.          (length (length counts)))
  56.         (do ((vop start-vop (vop-next vop)))
  57.         ((null vop))
  58.           (let ((vop-name (vop-info-name (vop-info vop))))
  59.         (do ((i 0 (+ i 4)))
  60.             ((or (>= i length) (eq (svref counts i) vop-name))
  61.              (when (>= i length)
  62.                (incf length 4)
  63.                (let ((new-counts
  64.                   (make-array length :initial-element 0)))
  65.              (when counts
  66.                (replace new-counts counts))
  67.              (setf counts new-counts))
  68.                (setf (svref counts i) vop-name))
  69.              (incf (svref counts (1+ i)))))))
  70.         (setf (svref vops index) counts)))))
  71.     (count-instructions
  72.      #'(lambda (vop bytes elsewherep)
  73.      (let ((block-number (block-number (ir2-block-block (vop-block vop)))))
  74.        (when block-number
  75.          (let* ((name (vop-info-name (vop-info vop)))
  76.             (counts (svref vops (1- block-number)))
  77.             (length (length counts)))
  78.            (do ((i 0 (+ i 4)))
  79.            ((>= i length)
  80.             (error "VOP ~S didn't exist earlier!~%  counts=~S"
  81.                name counts))
  82.          (when (eq (svref counts i) name)
  83.            (incf (svref counts (+ i (if elsewherep 3 2))) bytes)
  84.            (return)))))))
  85.      *code-segment*
  86.      *elsewhere*)
  87.     (undefined-value)))
  88.